home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / mwdenote < prev    next >
Text File  |  1993-05-10  |  9KB  |  273 lines
  1. ; Copyright 1992 William Clinger
  2. ;
  3. ; Permission to copy this software, in whole or in part, to use this
  4. ; software for any lawful purpose, and to redistribute this software
  5. ; is granted subject to the restriction that all copies made of this
  6. ; software must include this copyright notice in full.
  7. ;
  8. ; I also request that you send me a copy of any improvements that you
  9. ; make to this software so that they may be incorporated within it to
  10. ; the benefit of the Scheme community.
  11.  
  12. ;;;; Syntactic environments.
  13.  
  14. ; A syntactic environment maps identifiers to denotations,
  15. ; where a denotation is one of
  16. ;
  17. ;    (special <special>)
  18. ;    (macro <rules> <env>)
  19. ;    (identifier <id>)
  20. ;
  21. ; and where <special> is one of
  22. ;
  23. ;    quote
  24. ;    lambda
  25. ;    if
  26. ;    set!
  27. ;    begin
  28. ;    define
  29. ;    define-syntax
  30. ;    let-syntax
  31. ;    letrec-syntax
  32. ;    syntax-rules
  33. ;
  34. ; and where <rules> is a compiled <transformer spec> (see R4RS),
  35. ; <env> is a syntactic environment, and <id> is an identifier.
  36.  
  37. (define mw:standard-syntax-environment
  38.   '((quote         . (special quote))
  39.     (lambda        . (special lambda))
  40.     (if            . (special if))
  41.     (set!          . (special set!))
  42.     (begin         . (special begin))
  43.     (define        . (special define))
  44.     (let           . (special let))                ;; @@ added KAD
  45.     (let*          . (special let*))               ;; @@    "
  46.     (letrec        . (special letrec))             ;; @@    "
  47.     (quasiquote    . (special quasiquote))         ;; @@    "
  48.     (unquote       . (special unquote))            ;; @@    "
  49.     (unquote-splicing . (special unquote-splicing)) ; @@    "
  50.     (do            . (special do))                 ;; @@    "
  51.     (define-syntax . (special define-syntax))
  52.     (let-syntax    . (special let-syntax))
  53.     (letrec-syntax . (special letrec-syntax))
  54.     (syntax-rules  . (special syntax-rules))
  55.     (...           . (identifier ...))
  56.     (:::           . (identifier :::))))
  57.  
  58. ; An unforgeable synonym for lambda, used to expand definitions.
  59.  
  60. (define mw:lambda0 (string->symbol " lambda "))
  61.  
  62. ; The mw:global-syntax-environment will always be a nonempty
  63. ; association list since there is no way to remove the entry
  64. ; for mw:lambda0.  That entry is used as a header by destructive
  65. ; operations.
  66.  
  67. (define mw:global-syntax-environment
  68.   (cons (cons mw:lambda0
  69.           (cdr (assq 'lambda mw:standard-syntax-environment)))
  70.     (mw:syntax-copy mw:standard-syntax-environment)))
  71.  
  72. (define (mw:global-syntax-environment-set! env)
  73.   (set-cdr! mw:global-syntax-environment env))
  74.  
  75. (define (mw:syntax-bind-globally! id denotation)
  76.   (if (and (mw:identifier? denotation)
  77.        (eq? id (mw:identifier-name denotation)))
  78.       (letrec ((remove-bindings-for-id
  79.         (lambda (bindings)
  80.           (cond ((null? bindings) '())
  81.             ((eq? (caar bindings) id)
  82.              (remove-bindings-for-id (cdr bindings)))
  83.             (else (cons (car bindings)
  84.                     (remove-bindings-for-id (cdr bindings))))))))
  85.     (mw:global-syntax-environment-set!
  86.      (remove-bindings-for-id (cdr mw:global-syntax-environment))))
  87.       (let ((x (assq id mw:global-syntax-environment)))
  88.     (if x
  89.         (set-cdr! x denotation)
  90.         (mw:global-syntax-environment-set!
  91.          (cons (cons id denotation)
  92.            (cdr mw:global-syntax-environment)))))))
  93.  
  94. (define (mw:syntax-divert env1 env2)
  95.   (append env2 env1))
  96.  
  97. (define (mw:syntax-extend env ids denotations)
  98.   (mw:syntax-divert env (map cons ids denotations)))
  99.  
  100. (define (mw:syntax-lookup-raw env id)
  101.   (let ((entry (assq id env)))
  102.     (if entry
  103.     (cdr entry)
  104.     #f)))
  105.  
  106. (define (mw:syntax-lookup env id)
  107.   (or (mw:syntax-lookup-raw env id)
  108.       (mw:make-identifier-denotation id)))
  109.  
  110. (define (mw:syntax-assign! env id denotation)
  111.   (let ((entry (assq id env)))
  112.     (if entry
  113.     (set-cdr! entry denotation)
  114.     (mw:bug "Bug detected in mw:syntax-assign!" env id denotation))))
  115.  
  116. (define mw:denote-of-quote
  117.   (mw:syntax-lookup mw:standard-syntax-environment 'quote))
  118.  
  119. (define mw:denote-of-lambda
  120.   (mw:syntax-lookup mw:standard-syntax-environment 'lambda))
  121.  
  122. (define mw:denote-of-if
  123.   (mw:syntax-lookup mw:standard-syntax-environment 'if))
  124.  
  125. (define mw:denote-of-set!
  126.   (mw:syntax-lookup mw:standard-syntax-environment 'set!))
  127.  
  128. (define mw:denote-of-begin
  129.   (mw:syntax-lookup mw:standard-syntax-environment 'begin))
  130.  
  131. (define mw:denote-of-define
  132.   (mw:syntax-lookup mw:standard-syntax-environment 'define))
  133.  
  134. (define mw:denote-of-define-syntax
  135.   (mw:syntax-lookup mw:standard-syntax-environment 'define-syntax))
  136.  
  137. (define mw:denote-of-let-syntax
  138.   (mw:syntax-lookup mw:standard-syntax-environment 'let-syntax))
  139.  
  140. (define mw:denote-of-letrec-syntax
  141.   (mw:syntax-lookup mw:standard-syntax-environment 'letrec-syntax))
  142.  
  143. (define mw:denote-of-syntax-rules
  144.   (mw:syntax-lookup mw:standard-syntax-environment 'syntax-rules))
  145.  
  146. (define mw:denote-of-...
  147.   (mw:syntax-lookup mw:standard-syntax-environment '...))
  148.  
  149. (define mw:denote-of-:::
  150.   (mw:syntax-lookup mw:standard-syntax-environment ':::))
  151.  
  152. (define mw:denote-of-let
  153.   (mw:syntax-lookup mw:standard-syntax-environment 'let))        ;; @@ KenD
  154.  
  155. (define mw:denote-of-let*
  156.   (mw:syntax-lookup mw:standard-syntax-environment 'let*))       ;; @@ KenD
  157.  
  158. (define mw:denote-of-letrec
  159.   (mw:syntax-lookup mw:standard-syntax-environment 'letrec))     ;; @@ KenD
  160.  
  161. (define mw:denote-of-quasiquote
  162.   (mw:syntax-lookup mw:standard-syntax-environment 'quasiquote)) ;; @@ KenD
  163.  
  164. (define mw:denote-of-unquote
  165.   (mw:syntax-lookup mw:standard-syntax-environment 'unquote))    ;; @@ KenD
  166.  
  167. (define mw:denote-of-unquote-splicing
  168.   (mw:syntax-lookup mw:standard-syntax-environment 'unquote-splicing)) ;@@ KenD
  169.  
  170. (define mw:denote-of-do
  171.   (mw:syntax-lookup mw:standard-syntax-environment 'do))        ;; @@ KenD
  172.  
  173. (define mw:denote-class car)
  174.  
  175. ;(define (mw:special? denotation)
  176. ;  (eq? (mw:denote-class denotation) 'special))
  177.  
  178. ;(define (mw:macro? denotation)
  179. ;  (eq? (mw:denote-class denotation) 'macro))
  180.  
  181. (define (mw:identifier? denotation)
  182.   (eq? (mw:denote-class denotation) 'identifier))
  183.  
  184. (define (mw:make-identifier-denotation id)
  185.   (list 'identifier id))
  186.  
  187. (define macwork:rules cadr)
  188. (define macwork:env caddr)
  189. (define mw:identifier-name cadr)
  190.  
  191. (define (mw:same-denotation? d1 d2)
  192.   (or (eq? d1 d2)
  193.       (and (mw:identifier? d1)
  194.        (mw:identifier? d2)
  195.        (eq? (mw:identifier-name d1)
  196.         (mw:identifier-name d2)))))
  197.  
  198. ; Renaming of variables.
  199.  
  200. ; Given a datum, strips the suffixes from any symbols that appear within
  201. ; the datum, trying not to copy any more of the datum than necessary.
  202. ; Well, right now I'm just copying the datum, but I need to fix that!
  203.  
  204. (define (mw:strip x)
  205.   (cond ((symbol? x)
  206.      (let ((chars (memv mw:suffix-character
  207.                 (reverse (string->list
  208.                       (symbol->string x))))))
  209.        (if chars
  210.            (string->symbol
  211.         (list->string (reverse (cdr chars))))
  212.            x)))
  213.     ((pair? x)
  214.      (cons (mw:strip (car x))
  215.            (mw:strip (cdr x))))
  216.     ((vector? x)
  217.      (list->vector (map mw:strip (vector->list x))))
  218.     (else x)))
  219.  
  220. ; Given a list of identifiers, returns an alist that associates each
  221. ; identifier with a fresh identifier.
  222.  
  223. (define (mw:rename-vars vars)
  224.   (set! mw:renaming-counter (+ mw:renaming-counter 1))
  225.   (let ((suffix (string-append (string mw:suffix-character)
  226.                    (number->string mw:renaming-counter))))
  227.     (map (lambda (var)
  228.        (if (symbol? var)
  229.            (cons var
  230.              (string->symbol
  231.               (string-append (symbol->string var) suffix)))
  232.            (error "Illegal variable" var)))
  233.      vars)))
  234.  
  235. ; Given a syntactic environment env to be extended, an alist returned
  236. ; by mw:rename-vars, and a syntactic environment env2, extends env by
  237. ; binding the fresh identifiers to the denotations of the original
  238. ; identifiers in env2.
  239.  
  240. (define (mw:syntax-alias env alist env2)
  241.   (mw:syntax-divert
  242.    env
  243.    (map (lambda (name-pair)
  244.       (let ((old-name (car name-pair))
  245.         (new-name (cdr name-pair)))
  246.         (cons new-name
  247.           (mw:syntax-lookup env2 old-name))))
  248.     alist)))
  249.  
  250. ; Given a syntactic environment and an alist returned by mw:rename-vars,
  251. ; extends the environment by binding the old identifiers to the fresh
  252. ; identifiers.
  253.  
  254. (define (mw:syntax-rename env alist)
  255.   (mw:syntax-divert env
  256.             (map (lambda (old new)
  257.                (cons old (mw:make-identifier-denotation new)))
  258.              (map car alist)
  259.              (map cdr alist))))
  260.  
  261. ; Given a <formals> and an alist returned by mw:rename-vars that contains
  262. ; a new name for each formal identifier in <formals>, renames the
  263. ; formal identifiers.
  264.  
  265. (define (mw:rename-formals formals alist)
  266.   (cond ((null? formals) '())
  267.     ((pair? formals)
  268.      (cons (cdr (assq (car formals) alist))
  269.            (mw:rename-formals (cdr formals) alist)))
  270.     (else (cdr (assq formals alist)))))
  271.  
  272. (define mw:renaming-counter 0)
  273.